home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / vaxkernel.t < prev    next >
Text File  |  1988-02-12  |  23KB  |  679 lines
  1. (herald unvaxkernel (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. (define (vax-big-bang)
  27.   (lap (big_bang handle-stack-base
  28.          icall-bad-proc icall-wrong-nargs
  29.          handle-undefined-effect
  30.         really-gc pc-code-vector
  31.         heap-overflow-error call-fault-handler cont-wrong-nargs)
  32.  
  33.  
  34.     (movl  nil-reg (d@r nil-reg -3))            ; (cdr '()) = '()
  35.     (movl  nil-reg (d@r nil-reg 1))             ; (car '()) = '()
  36.     (movl  P (d@r nil-reg slink/kernel))        ; save kernel pointer
  37.     (moval (label %undefined-effect)  (d@r nil-reg slink/undefined-effect))
  38.     (moval (label %make-pair)         (d@r nil-reg slink/make-pair))
  39.     (moval (label %make-extend)       (d@r nil-reg slink/make-extend))
  40.     (moval (label %nary-setup)        (d@r nil-reg slink/nary-setup))
  41.     (moval (label %set)               (d@r nil-reg slink/set))
  42.     (moval (label %icall)             (d@r nil-reg slink/icall))
  43.     (moval (label %cont-wrong-nargs)  (d@r nil-reg slink/cont-wrong-nargs))
  44.     (moval (label %kernel-begin)      (d@r nil-reg slink/kernel-begin))
  45.     (moval (label %kernel-end)        (d@r nil-reg slink/kernel-end))
  46.  
  47.     ;; initialize root process, stored in outer space?  
  48.  
  49.     ;; zero out extra registers
  50.     (movl ($ (fx/ temp-block-size 4)) S0)
  51. initialize-loop     
  52.     (clrl (@-r sp))  
  53.     (decl S0)
  54.     (j> initialize-loop)
  55.  
  56.     (movl   SP TASK)                            ; load task reg
  57.     (addl2  ($ (fx+ %%task-header-offset 4)) sp); allocate task block
  58.     (pushl  ($ header/task))                    ; task header
  59.     (addl3  ($ 2) SP A3)                        ; extend pointer
  60.     (movl   A3 (d@r NIL-REG slink/root-process)); ptr to root and
  61.     (movl   A3 (d@r NIL-REG slink/current-task)); current process
  62.  
  63.     ;; initialize stack
  64.     (pushl A3)                                 ; task block
  65.     (pushl nil-reg)                             ; no parent
  66.     (pushl ($ 0))                               ; active, no current sz
  67.     (pushl ($ (fixnum-ashl %%stack-size 2)))    ; total stack size
  68.     (pushl  ($ #xBADBAD))                       ; distinguished value
  69.     (pushal (label stack-base-template))        ; stack base
  70.  
  71.     ;; initialize root process
  72. ;***** (addl3 ($ 2) SP (d@r TASK task/stack))
  73.     (movl SP (d@r TASK task/stack))
  74.     (clrl (d@r TASK task/extra-pointer))
  75.     (clrl (d@r TASK task/extra-scratch))
  76.     (movl nil-reg (d@r TASK task/dynamic-state))
  77.  
  78.     (movl nil-reg (d@r TASK task/doing-gc?))
  79.     (clrl (d@r TASK task/foreign-call-cont))
  80.     (clrl (D@r TASK task/critical-count))
  81.     (movl nil-reg (d@r TASK task/k-list))
  82.     (movl nil-reg (d@r TASK task/gc-weak-set-list))
  83.     (movl nil-reg (d@r TASK task/gc-weak-alist-list))
  84.     (movl nil-reg (d@r TASK task/gc-weak-table-list))
  85.     (movl nil-reg (d@r nil-reg slink/snapper-freelist))
  86.     (movl nil-reg (d@r nil-reg slink/pair-freelist))
  87.     (movl (d@r P (static 'big_bang)) P)
  88.     (movl (d@r p 2) p)
  89.     (jmp (@r TP))
  90.  
  91. %make-pair
  92.     ;; return pair in AN
  93.     (bisb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  94.     (addl3 ($ 8) (d@r TASK task/area-frontier) AN)
  95.     (cmpl AN (d@r TASK task/area-limit))
  96.     (j> %make-pair-heap-overflow)
  97. %make-pair-continue
  98.     (movl AN (d@r TASK task/area-frontier))
  99.     (subl2 ($ (fx- 8 tag/pair)) AN)
  100.     (clrq (d@r AN -3))
  101.     (bicb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  102.     (jn= %deferred-interrupts)
  103.     (rsb)
  104.  
  105. %make-pair-heap-overflow
  106.     (movl ($ header/true) (d@r TASK task/doing-gc?))
  107.     (jsb (label %heap-overflow))
  108.     (addl3 ($ 8) (d@r TASK task/area-frontier) AN)
  109.     (cmpl AN (d@r TASK task/area-limit))
  110.     (j> %horrible-heap-overflow)
  111.     (bisb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  112.     (movl nil-reg (d@r TASK task/doing-gc?))
  113.     (jmp (label %make-pair-continue))
  114.     
  115.  
  116. %make-extend
  117.     ;; receive descriptor in An, size in bytes S1,
  118.     ;; return extend in AN.
  119.     (bisb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  120.     (movl (d@r TASK task/area-frontier) S2) 
  121.     (addl2 ($ 4) S1)                           
  122.     (addl2 S2 S1)
  123.     (cmpl S1 (d@r TASK task/area-limit))
  124.     (j> %make-extend-heap-overflow)
  125. %make-extend-continue  
  126.     (movl S1 (d@r TASK task/area-frontier))
  127.     (movl AN (@r+ S2))
  128.     (cmpl S1 S2)
  129.     (j= copy-done)
  130.     (movl S2 AN)
  131. extend-loop
  132.     (clrl (@r+ AN))
  133.     (cmpl S1 AN)
  134.     (j> extend-loop)
  135. copy-done
  136.     (subl3 ($ tag/extend) S2 AN)
  137.     (bicb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  138.     (jn= %deferred-interrupts)
  139.     (rsb)
  140.    
  141. %make-extend-heap-overflow
  142.     (movl ($ header/true) (d@r TASK task/doing-gc?))
  143.     (subl2 S2 S1)
  144.     (jsb (label %heap-overflow))
  145.     (movl (d@r TASK task/area-frontier) S2) ; get area-frontier
  146.     (addl2 S2 S1)                          ; one for the descriptor
  147.     (cmpl S1 (d@r TASK task/area-limit))
  148.     (j> %horrible-heap-overflow)
  149.     (bisb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  150.     (movl nil-reg (d@r TASK task/doing-gc?))
  151.     (jmp (label  %make-extend-continue))
  152.                       
  153. %heap-overflow
  154.     (pushl S0)                  ; save scratch registers
  155.     (pushl S1)
  156.     (pushl S2)
  157.     (pushl S3)
  158.     (movl ($ (fx/ temp-block-size 4)) S0)
  159. save-loop                                  ; save temps
  160.     (pushl (index (d@r TASK -4) S0))
  161.     (decl S0)
  162.     (j>= save-loop)
  163.     (pushl TP)
  164.     (pushl AN)
  165.     (pushl A4)
  166.     (pushl A3)
  167.     (pushl A2)
  168.     (pushl A1)
  169.     (pushl P)
  170.     (movl (d@r SP (* (+ *no-of-registers* 3) 4)) A1)   ; one for TP 2 return
  171.     (pushal (label pc-check-return))
  172.     (movl (d@r nil-reg slink/kernel) P)
  173.     (movl (d@r P (static 'pc-code-vector)) P)
  174.     (movl (d@r p 2) p)
  175.     (movl (d@r P -2) TP)
  176.     (jmp (@r TP))                                ; call pc-code-vector
  177.            
  178. ;;; the template header byte has high bit set if nary
  179.  
  180. %icall                     
  181.   (bicb3 ($ #b11111100) P S0)
  182.   (cmpb S0 ($ tag/extend))                     ; check proc is extend
  183.   (jn= %icall-bad-proc)
  184.   (movl (d@r P -2) TP)                         ; fetch header
  185.   (bicb3 ($ #b11111100) TP S0)                 ; check header is extend
  186.   (cmpb S0 ($ tag/extend))
  187.   (jn= %icall-bad-proc)
  188.   (cmpb (d@r TP -2) ($ header/template))       ; check header is template
  189.   (jn= %icall-check-nary)
  190.   (cmpb (d@r TP template/nargs) NARGS)         ; check number of args
  191.   (j= %icall-ok)
  192.   (jmp (label %icall-wrong-nargs))
  193. %icall-check-nary
  194.   (cmpb (d@r TP -2) ($ (fx+ header/template 128)))
  195.   (jn= %icall-bad-proc)
  196.   (cmpb (d@r TP template/nargs) NARGS)
  197.   (j> %icall-wrong-nargs)
  198. %icall-ok
  199.   (jmp (@r TP))
  200.  
  201. %icall-bad-proc
  202.   (movl a1 (d@r TASK task/t0))
  203.   (movl a2 (d@r TASK (fx+ task/t0 4)))
  204.   (movl a3 (d@r TASK (fx+ task/t0 8)))
  205.   (movl a4 (d@r TASK (fx+ task/t0 12)))
  206.   (clrl s0)
  207.   (jsb (label %nary-setup))
  208.   (movl an a2)
  209.   (movl p a1)
  210.   (movl (d@r nil-reg slink/kernel) P)
  211.   (movl (d@r P (static 'icall-bad-proc)) P)
  212.   (movl (d@r p 2) p)
  213.   (movl (d@r P -2) TP)
  214.   (jmp  (@r TP))
  215.  
  216. %icall-wrong-nargs
  217.   (movl a1 (d@r TASK task/t0))
  218.   (movl a2 (d@r TASK (fx+ task/t0 4)))
  219.   (movl a3 (d@r TASK (fx+ task/t0 8)))
  220.   (movl a4 (d@r TASK (fx+ task/t0 12)))
  221.   (clrl s0)
  222.   (jsb (label %nary-setup))
  223.   (movl an a2)
  224.   (movl p a1)
  225.   (movl (d@r nil-reg slink/kernel) P)
  226.   (movl (d@r P (static 'icall-wrong-nargs)) P)
  227.   (movl (d@r p 2) p)
  228.   (movl (d@r P -2) TP)
  229.   (jmp  (@r TP))
  230.  
  231.  
  232.  
  233. %deferred-interrupts
  234.     (pushl S3)
  235.     (pushl S2)
  236.     (pushl S1)
  237.     (pushl S0)
  238.     (movl ($ (fx/ (fx+ temp-block-size 4) 4)) S2)
  239. %int-save-loop                              ; save temps and extra p and s
  240.     (pushl (index (d@r TASK -8) S2))
  241.     (decl S2)
  242.     (j>= %int-save-loop)
  243.     (pushl TP)
  244.     (pushl AN)
  245.     (pushl A4)
  246.     (pushl A3)
  247.     (pushl A2)
  248.     (pushl A1)
  249.     (pushl P)
  250.     (pushl ($ 0))               ; pc
  251.     (pushl (d@r SP (* (+ *pointer-temps* *scratch-temps* 14) 4)))
  252.     (pushl ($ 0))               ; no pointers on top
  253.     (pushl ($ (+ (fixnum-ashl (+ *pointer-temps* *scratch-temps* 16) 8)
  254.                    header/fault-frame)))
  255.     (pushal (label %int-return))
  256.     (movl (d@r nil-reg slink/kernel) P)
  257.     (movl (d@r P (static 'call-fault-handler)) P)
  258.     (movl (d@r p 2) p)
  259.     (movl (d@r P -2) TP)                      
  260.     (jmp (@r TP))
  261.  
  262.  
  263. %kernel-begin
  264.  
  265. %cont-wrong-nargs
  266.   (mnegl nargs nargs)
  267.   (movl a1 (d@r TASK task/t0))
  268.   (movl a2 (d@r TASK (fx+ task/t0 4)))
  269.   (movl a3 (d@r TASK (fx+ task/t0 8)))
  270.   (movl a4 (d@r TASK (fx+ task/t0 12)))
  271.   (clrl s0)
  272.   (jsb (label %nary-setup))
  273.   (movl an a2)
  274.   (moval (d@r sp 2) a1)
  275.   (movl (d@r nil-reg slink/kernel) P)
  276.   (movl (d@r P (static 'cont-wrong-nargs)) P)
  277.   (movl (d@r p 2) p)
  278.   (movl (d@r P -2) TP)
  279.   (jmp  (@r TP))
  280.                 
  281. %post-gc-nary-setup
  282.   (mnegl ($ 1) S1)
  283.   (jmp (label %real-nary-setup))
  284.   
  285.  
  286. %nary-setup                                 ; required args in S0
  287.   (clrl S1)
  288. %real-nary-setup
  289.   (subl2 ($ 2) NARGS)                      
  290.   (movl P (d@r TASK task/extra-pointer))
  291.   (movl nil-reg AN)
  292.   (bisb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  293.   (jmp (label %nary-test))
  294. %nary-loop
  295.   (movl AN P)                               ; accumulate in P
  296.   (addl3 ($ 8) (d@r TASK task/area-frontier) AN)
  297.   (cmpl AN (d@r TASK task/area-limit))
  298.   (j> %nary-make-pair-heap-overflow)
  299. %nary-make-pair-continue                        ; lose, lose
  300.   (movl AN (d@r TASK task/area-frontier))
  301.   (subl2 ($ (fx- 8 tag/pair)) AN)
  302.   (clrq (d@r AN -3))
  303.   (movl P (d@r AN -3))                      ; set cdr
  304.   (movl (index (@r TASK) NARGS) (d@r AN 1))    ; set car
  305.   (decl NARGS)
  306. %nary-test
  307.   (cmpl NARGS S0)                              ; redundant?
  308.   (j>= %nary-loop)
  309.   (tstl S1)
  310.   (jn= nary-clear-extras)
  311.   (movl (d@r TASK task/extra-pointer) P)                         ; restore P and return
  312.   (bicb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  313.   (jn= %deferred-interrupts)
  314.   (rsb)
  315. nary-clear-extras
  316.   (cmpl ($ 4) S0)
  317.   (j<= foo45)
  318.   (movl ($ 4) S0)
  319. foo45
  320.   (clrl (index (@r TASK) S0))
  321.   (incl S0)
  322.   (cmpl ($ (fx/ temp-block-size 4)) S0)
  323.   (j> foo45)
  324.   (moval (label %nary-setup) (d@r nil-reg slink/nary-setup))
  325.   (movl (d@r TASK task/extra-pointer) P)                            
  326.   (bicb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  327.   (jn= %deferred-interrupts)
  328.   (rsb)     
  329.  
  330. %nary-make-pair-heap-overflow
  331.     (movl ($ header/true) (d@r TASK task/doing-gc?))
  332.     (jsb (label %heap-overflow))
  333.     (movl (d@r TASK task/area-frontier) AN)
  334.     (addl2 ($ 8) AN)
  335.     (cmpl AN (d@r TASK task/area-limit))
  336.     (j> %horrible-heap-overflow)
  337.     (bisl2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  338.     (movl nil-reg (d@r TASK task/doing-gc?))
  339.     (jmp (label %nary-make-pair-continue))
  340.  
  341. %set                                        ; a location is (unit  . index)
  342.    ;;  vcell in extra-pointer
  343.    (bisb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  344.    (pushl s1)
  345.    (pushl s0)
  346.    (pushl an)
  347.    (pushl a3)
  348.    (pushl a2)
  349.    (pushl a1)
  350.    (pushl p)
  351.    (movl (d@r TASK task/extra-pointer) a3)
  352.    (movl (d@r A3 6) A1)                  ; get locations
  353.    (movl (d@r A1 2) A1)                  ; get the vector in A1
  354.    (ashl ($ -8) (d@r A1 -2) S0)
  355.    (jmp (label %set-test))
  356. %set-loop
  357.    (movl (d@r nil-reg slink/snapper-freelist) an)
  358.    (cmpl an nil-reg)
  359.    (j= cons-snapper)
  360.    (movl (d@r an 1) p)
  361.    (movl (d@r an -3) (d@r nil-reg slink/snapper-freelist))
  362.    (movl (d@r nil-reg slink/pair-freelist) (d@r an -3))
  363.    (movl an (d@r nil-reg slink/pair-freelist))
  364. %real-top
  365.    (movl (index (d@r A1 -6) S0) A2)      ; get unit
  366.    (ashl ($ -2) (index (d@r A1 -2) S0) S1)      ; get index
  367.    (movl (d@r a3 2) (d@r p 2))
  368.    (movl a2 (d@r p 6))
  369.    (ashl ($ 2) s1 (d@r p 10))
  370.    (movl p (index (d@r A2 2) s1))
  371.    (subl2 ($ 2) S0)
  372. %set-test
  373.    (tstl S0)
  374.    (jn= %set-loop)
  375.    (movl (@r+ sp) p)
  376.    (movl (@r+ sp) a1)
  377.    (movl (@r+ sp) a2)
  378.    (movl (@r+ sp) a3)
  379.    (movl (@r+ sp) an)
  380.    (movl (@r+ sp) s0)
  381.    (movl (@r+ sp) s1)
  382.    (bicb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  383.    (jn= %deferred-interrupts)
  384.    (rsb)
  385. cons-snapper
  386.    (movl (d@r TASK task/area-frontier) AN)
  387.    (addl2 ($ 16) AN)
  388.    (cmpl AN (d@r TASK task/area-limit))
  389.    (j> %set-heap-overflow)
  390. %set-continue                        ; lose, lose
  391.    (movl AN (d@r TASK task/area-frontier))
  392.    (moval (d@r an -14) p)
  393.    (moval (label link-snapper) a2)
  394.    (movl a2 (d@r p -2))
  395.    (jmp (label %real-top))
  396. %set-heap-overflow
  397.     (movl ($ header/true) (d@r TASK task/doing-gc?))
  398.     (pushl ($ (+ (fixnum-ashl 5 16) (fixnum-ashl 3 8) header/vframe )))
  399.     (pushl (d@r sp 32))
  400.     (jsb (label %heap-overflow))
  401.     (movl (@r sp) (d@r sp 36))
  402.     (addl2 ($ 8) sp)
  403.     (movl (d@r TASK task/area-frontier) AN)
  404.     (addl2 ($ 16) AN)
  405.     (cmpl AN (d@r TASK task/area-limit))
  406.     (j> %horrible-heap-overflow)
  407.     (bisl2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  408.     (movl nil-reg (d@r TASK task/doing-gc?))
  409.     (jmp (label %set-continue))
  410.  
  411. %kernel-end
  412.         
  413. %horrible-heap-overflow
  414.   (addl2 ($ 4) SP)
  415.   (bicb2 ($ #b10000000) (d@r TASK (fx+ task/critical-count 3)))
  416.   (movl nil-reg (d@r TASK task/doing-gc?))
  417.   (movl (d@r nil-reg slink/kernel) P)
  418.   (movl (d@r P (static 'heap-overflow-error)) P)
  419.   (movl (d@r p 2) p)
  420.   (movl (d@r P -2) TP)
  421.   (jmp (@r TP))
  422.   
  423.  
  424.  
  425. %undefined-effect
  426.   (movl TP A2)
  427.   (movl (d@r nil-reg slink/kernel) P)
  428.   (movl (d@r P (static 'handle-undefined-effect)) P)
  429.   (movl (d@r p 2) p)
  430.   (movl (d@r P -2) TP)
  431.   (jmp (@r TP))
  432. ))                         
  433.  
  434. (lap-template (0 0 -1 t stack %int-return-handler)
  435. %int-return
  436.     (movl (d@r SP 12) (d@r SP (* (+ *pointer-temps* *scratch-temps* 18) 4)))
  437.     (addl2 ($ 20) sp)        ; pop template,header,pointers on stack,hack top,pc
  438.     (movl (@r+ SP) P)
  439.     (movl (@r+ SP) A1)
  440.     (movl (@r+ SP) A2)
  441.     (movl (@r+ SP) A3)
  442.     (movl (@r+ SP) A4)
  443.     (movl (@r+ SP) AN)
  444.     (movl (@r+ SP) TP)
  445.     (movl ($ -2) S0)
  446. %int-return-restore-loop                                  ; restore temps
  447.     (movl (@r+ SP) (index (@r TASK) S0))
  448.     (incl S0)
  449.     (cmpl ($ (fx/ temp-block-size 4)) S0)          
  450.     (j> %int-return-restore-loop)
  451.     (movl (@r+ SP) S0)
  452.     (movl (@r+ SP) S1)
  453.     (movl (@r+ SP) S2)
  454.     (movl (@r+ SP) S3)
  455.     (rsb)
  456. %int-return-handler
  457.     (movl nil-reg an)
  458.     (rsb))
  459.  
  460.                               
  461.         
  462. (define (clear-extra-registers)
  463.   (lap ()
  464.     (mnegl ($ 1) S0)
  465. zero-loop                                  ; restore temps
  466.     (clrl (index (@r TASK) S0))
  467.     (incl S0)
  468.     (cmpl ($ (fx/ temp-block-size 4)) S0)
  469.     (j> zero-loop)
  470.     (mnegl ($ 2) NARGS)
  471.     (movl (@r sp) tp)
  472.     (jmp (@r tp))))
  473.  
  474.  
  475. (lap-template (0 0 -1 t stack pc-check-return-handler) 
  476. pc-check-return
  477.     (addl2 ($ 4) SP)                            ; pop return address
  478.     (pushl A1)                                  ; code vector of pc
  479.     (pushal (d@r A1 -2))                            ; fixnumized code vector
  480.     (pushal (label gc-template))
  481.     (movl (d@r nil-reg slink/kernel) P)
  482.     (movl (d@r P (static 'really-gc)) P)
  483.   (movl (d@r p 2) p)
  484.     (movl (d@r P -2) TP)
  485.     (jmp (@r TP))
  486. pc-check-return-handler
  487.   (movl nil-reg AN)
  488.   (rsb))
  489.  
  490.                  
  491. ;;; sizes of gc template:
  492. ;;; pointer -- n registers + n temps + 1 extra + 2 code vector + tp
  493. ;;; scratch -- gc return address + 1 other + n registers + n temps
  494.  
  495. (lap-template ((+ *pointer-temps* *pointer-registers* 4) 
  496.                (+ *scratch-temps* *scratch-registers* 2) 
  497.                -1 t stack gc-template-handler)       ;; see gc.t
  498. gc-template
  499.   (moval (label %post-gc-nary-setup) (d@r nil-reg slink/nary-setup))
  500.   (addl2 ($ 4) SP)                                  ; pop template 
  501.   (movl (@r+ SP) S0)                              ; pop old code (fixnum)
  502.   (movl (@r+ SP) S1)                              ; pop relocated code
  503.   (cmpl S1 nil-reg)
  504.   (j= gc-continue)                                  ; not relocated
  505.   (subl2 ($ 2) S1)                                  ; fixnumize new code
  506.   (subl3 S0 (d@r SP (fx* (+ *no-of-registers* 3) 4)) S2) ; get old pc
  507.   (addl3 S2 S1 (d@r SP (fx* (+ *no-of-registers* 3) 4)))     ; update pc
  508. gc-continue
  509.   (movl (@r+ SP) P)
  510.   (movl (@r+ SP) A1)
  511.   (movl (@r+ SP) A2)
  512.   (movl (@r+ SP) A3)
  513.   (movl (@r+ SP) A4)
  514.   (movl (@r+ SP) AN)
  515.   (movl (@r+ SP) TP)
  516.   (mnegl ($ 1) S0)
  517. restore-loop                                  ; restore temps
  518.   (movl (@r+ SP) (index (@r TASK) S0))
  519.   (incl S0)
  520.   (cmpl ($ (fx/ temp-block-size 4)) S0)
  521.   (j> restore-loop)
  522.   (movl (@r+ SP) S3)
  523.   (movl (@r+ SP) S2)
  524.   (movl (@r+ SP) S1)
  525.   (movl (@r+ SP) S0)
  526.   (rsb)
  527. gc-template-handler
  528.   (movl nil-reg AN)
  529.   (rsb))
  530.                           
  531.  
  532.                                                             
  533. (lap-template (0 0 0 nil stack stack-base-handler)
  534. stack-base-template
  535.   (jmp (*d@r nil-reg slink/undefined-effect))
  536. stack-base-handler
  537.   (movl (d@r nil-reg slink/kernel) AN)
  538.   (movl (d@r AN (static 'handle-stack-base)) A1)
  539.   (movl (d@r a1 2) a1)
  540.   (jmp (*d@r nil-reg slink/dispatch-label)))
  541.     
  542.  
  543.     
  544. (define (lap-relocate frame old-tp new-tp offset)
  545.   (lap ()                 
  546.     (ashl ($ -2) A4 A4)                  ; offset
  547.     (movl (index (d@r A1 2) A4) S1)   ; code
  548.     (subl2 A2 S1)                       ; code-offset
  549.     (addl2 S1 A3)                       ; new code
  550.     (movl A3 (index (d@r A1 2) A4))
  551.     (mnegl ($ 1) NARGS)
  552.     (movl (@r sp) tp)
  553.     (jmp (@r tp))))
  554.  
  555.  
  556. (define (current-task)
  557.  (lap ()
  558.   (movl TASK A1)
  559.   (addl2 ($ (fx+ %%task-header-offset 2)) A1)   ; offset is negative !
  560.   (mnegl ($ 2) nargs)
  561.     (movl (@r sp) tp)
  562.     (jmp (@r tp))))
  563.  
  564.  
  565. ; debugger hacks
  566.  
  567. (define (@@ address)    ; randomness
  568.   (lap ()
  569.     (addl2 ($ 2) a1)
  570.     (mnegl ($ 2) nargs)
  571.     (movl (@r sp) tp)
  572.     (jmp (@r tp))))
  573.  
  574. (define-foreign gc_interrupt (gc_interrupt) ignore)
  575.  
  576. (define (crawl-exhibit-fault-frame frame)
  577.   (cond ((not (foreign-fault-frame? frame))       ; foreign
  578.          (print-register frame 'p 3)
  579.          (print-register frame 'a1 4)
  580.          (print-register frame 'a2 5)
  581.          (print-register frame 'a3 6)
  582.          (print-register frame 'a4 7)
  583.          (print-register frame 'an 8)
  584.          (print-register frame 'tp 9))
  585.         (else
  586.          (format t " In foreign code; no information available~%"))))
  587.  
  588.  
  589. (define (trace-fault-frame frame)
  590.   (cond ((alt-bit-set? frame)          
  591.          (move-object (make-pointer frame 0)))           ; foreign cont
  592.         (else
  593.          (let ((tp (extend-elt frame 9)))                ; old TP
  594.            (trace-pointers (make-pointer frame 2) 
  595.                            (fx+ *pointer-registers* 1))     ; trace registers
  596.            (trace-pointers 
  597.             (make-pointer frame (fx+ *pointer-registers* 4))  ; trace temps
  598.             (fx+ *pointer-temps* 1))
  599.            (let ((ptrs (extend-elt frame 0))             ; trace top of stack
  600.                  (size (fault-frame-slots frame)))
  601.              (trace-pointers (make-pointer frame (fx- size 1)) ptrs))
  602.            (if (eq? (extend-elt frame 1) 0)              ; hack-top-of-stack?
  603.                (relocate-random-code frame 2 tp)         ; relocate PC
  604.                (relocate-random-code frame 1 tp))))))    ; relocate top-of-stack
  605.  
  606. (define (relocate-random-code frame offset old-tp)
  607.   (if (in-old-space? (extend-elt frame offset))
  608.       (lap-relocate frame 
  609.                     old-tp 
  610.                     (extend-elt frame (fx+ *pointer-registers* 3)) 
  611.                     offset)))
  612.  
  613. (define (make-link-snapper value unit i)
  614.   (lap ()
  615.     (movl (d@r nil-reg slink/snapper-freelist) p)
  616.     (cmpl p nil-reg)
  617.     (j= cons-snapper-1)
  618.     (movl (d@r p 1) an)
  619.     (movl (d@r p -3) (d@r nil-reg slink/snapper-freelist))
  620.     (movl (d@r nil-reg slink/pair-freelist) (d@r p -3))
  621.     (movl p (d@r nil-reg slink/pair-freelist))
  622. foobarfoo
  623.     (movl a1 (d@r an 2))
  624.     (movl a2 (d@r an 6))
  625.     (movl a3 (d@r an 10))
  626.     (movl an a1)
  627.     (mnegl ($ 2) nargs)
  628.     (movl (@r sp) tp)
  629.     (jmp (@r tp))
  630. cons-snapper-1    
  631.     (moval (label link-snapper) an)
  632.     (movl ($ 12) s1)
  633.     (jsb (label %make-extend))
  634.     (jmp (label foobarfoo))))
  635.  
  636. (define *link-snapper-template*
  637. (lap-template (3 0 1 t heap handle-snapper)
  638. link-snapper
  639.   (movl p an)
  640.   (movl (d@r p 2) p)
  641.   (bicb3 ($ #b11111100) P S0)
  642.   (cmpb S0 ($ tag/extend))                     ; check proc is extend
  643.   (jn= %icall-bad-proc)
  644.   (movl (d@r P -2) TP)                         ; fetch header
  645.   (bicb3 ($ #b11111100) TP S0)                 ; check header is extend
  646.   (cmpb S0 ($ tag/extend))
  647.   (jn= %icall-bad-proc)
  648.   (cmpb (d@r TP -2) ($ header/template))       ; check header is template
  649.   (jn= %icall-check-nary)
  650.   (cmpb (d@r TP template/nargs) NARGS)         ; check number of args
  651.   (j= snap-link)
  652.   (jmp (label %icall-wrong-nargs))
  653. %icall-check-nary
  654.   (cmpb (d@r TP -2) ($ (fx+ header/template 128)))
  655.   (jn= %icall-bad-proc)
  656.   (cmpb (d@r TP template/nargs) NARGS)
  657.   (j> %icall-wrong-nargs)
  658. snap-link
  659.   (movl an (d@r task task/extra-pointer))
  660.   (ashl ($ -2) (d@r an 10) s0)
  661.   (movl (d@r an 6) an)
  662.   (movl p (index (d@r an 2) s0))
  663.   (movl (d@r nil-reg slink/pair-freelist) an)
  664.   (cmpl an nil-reg)
  665.   (j= cons-pair)
  666.   (movl (d@r an -3) (d@r nil-reg slink/pair-freelist))
  667. consed-pair
  668.   (movl (d@r task task/extra-pointer) (d@r an 1))
  669.   (movl (d@r nil-reg slink/snapper-freelist) (d@r an -3))
  670.   (movl an (d@r nil-reg slink/snapper-freelist))
  671.   (jmp (@r TP))
  672. cons-pair
  673.   (jsb (label %make-pair))
  674.   (jmp (label consed-pair))
  675. handle-snapper
  676.   (movl nil-reg AN)
  677.   (rsb)))
  678.  
  679.